home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Plurals / rectangle.emc < prev    next >
Lisp/Scheme  |  1992-07-05  |  9KB  |  263 lines
  1. ;
  2. ;    Rectangular Paralations
  3. ;    
  4. ;    File        : rectangle
  5. ;
  6. ;    Contents    : make-rectangle, N, S, E and W
  7. ;
  8. ;    Description    : Indeed most unprecedented hackery to create tiled
  9. ;              virtual paralations which can makle use of the
  10. ;              xnet of the MasPar for nearest neighbour
  11. ;              Communication
  12. ;
  13. ;    Author        : SCM
  14. ;    
  15. ;    Change History
  16. ;    
  17. ;    Date    Name    Comment
  18. ;     17:06:92  SCM    Created
  19. ;
  20.  
  21. #include "mp_arith.h"
  22.  
  23. (defmodule rectangle (standard0 ppl plural) ()
  24.  
  25. ; SOme constant thingies 
  26.  
  27.  
  28. (setq global-field (make-paralation 512))
  29.  
  30. (defun list-tail (list n)
  31.   ;; returns the rest of the list from element n onwards
  32.   (cond 
  33.    ((null list) ())
  34.    ((= n 0) list)
  35.    (t (list-tail (cdr list) (- n 1)))))
  36.  
  37.  
  38. (defun get-context (width height)
  39.   ;; If the requested context is the global context, it uses
  40.   ;; MP-Context as defined in ppl
  41.   (if (and (= width MP-X-Config) (= height MP-Y-Config)) MP-Context
  42.     (mp-make-context width height)))
  43.  
  44. (defun tile-x (w h last-ctxt)
  45.   ;; Generates a list of contexts for one strip of a tiled  virtual
  46.   ;; processor set, if possible it reuses the previous context.
  47.   (cond
  48.    ((<= w 0) ())
  49.    ((< w MP-X-Config) (cons (get-context w h) ()))
  50.    (t (let ((new (if last-ctxt last-ctxt
  51.            (mp-make-context MP-X-Config h))))
  52.     (cons new (tile-x (- w MP-X-Config) h new))))))
  53.  
  54. (defun number-one (ctxt l-w g-w start)
  55.   ;; Numbers one context of a tiled virtual processor set, start is
  56.   ;; the value in the top-left pe, l-w is the width of the tile and
  57.   ;; g-w is the width of the virtual rectangle of pes
  58.   (format t "(number-one ~a ~a ~a ~a)\n" ctxt l-w g-w start)
  59.   (let ((ofst (mp-bang ctxt 1)))
  60.     (mp-edge ctxt MP_WEST)
  61.     (mp-assign ctxt ofst (mp-bang ctxt (+ (- g-w l-w) 1)))
  62.     (mp-fi ctxt)
  63.     (mp-set ctxt ofst 0 start)
  64.     (mp-assign ctxt ofst (mp-scan-op ctxt ofst MP_PLUS))))
  65.  
  66. (defun shared-ctxt-p (ctxt-list)
  67.   ;; Used to see if the next context is the same as the current one,
  68.   ;; if it is we can use the current enumeration to calculate the next
  69.   ;; one so it is passed to the next call of number-x
  70.   (if (null (cdr ctxt-list)) ()
  71.     (= (car ctxt-list) (cadr ctxt-list))))
  72.  
  73. (defun number-x (ctxt-list last start width left)
  74.   ;; Generates enumeration plurals for one row of contexts of a tiled
  75.   ;; virtual processor set. start is the value of the top left virtual
  76.   ;; pe. Where the context is shared the values can be derrived from
  77.   ;; the previous one.
  78.   (let ((ofst (cond
  79.            ((null ctxt-list) ())
  80.            ((null last) 
  81.         (number-one (car ctxt-list)
  82.                   (if (> left MP-X-Config) MP-X-Config left)
  83.                 width start))
  84.            (t (mp-bin-op (car ctxt-list) last
  85.                  (mp-bang (car ctxt-list) MP-X-Config) MP_PLUS)))))
  86.     (if (null ofst) ()
  87.       (cons ofst (number-x (cdr ctxt-list) 
  88.                (if (shared-ctxt-p ctxt-list) ofst ()) 
  89.                (+ start MP-X-Config) width (- left MP-X-Config))))))
  90.  
  91.   
  92. (defun l-tile (width height last-ctxt-list start)
  93.   ;; creates a list of pairs of lists of contexts and offsets. Each of
  94.   ;; the pairs represents one horizontal strip of a tiled virtual
  95.   ;; processor set. These can then be turned into a list of contexts
  96.   ;; and a list of offsets as used in the field/paralation format
  97.   (let ((new-ctxt-list (cond 
  98.             ((<= height 0) ())
  99.             ((< height MP-Y-Config) (tile-x width height ()))
  100.             (t (if last-ctxt-list last-ctxt-list
  101.                  (tile-x width MP-Y-Config ()))))))
  102.     (if (null new-ctxt-list) ()
  103.       (cons
  104.        (cons new-ctxt-list (number-x new-ctxt-list () start width width))
  105.        (l-tile width (- height MP-Y-Config) new-ctxt-list 
  106.            (+ start (* width MP-Y-Config)))))))
  107.  
  108. (defun dispair (l)
  109.   ;; Takes a list of pairs of lists and appends them all into a pair
  110.   ;; of lists (which is much more useful!)
  111.   (if (null l) '(())
  112.     (let ((tmp (dispair (cdr l))))
  113.       (if (null tmp) '(())
  114.     (cons (append (caar l) (car tmp))
  115.           (append (cdar l) (cdr tmp)))))))
  116.  
  117. (defun tile (width height)
  118.   ;; Produces a list of contexts and a list of offsets, which define
  119.   ;; and enumerate a tiled virtual processor set.
  120.   (dispair (l-tile width height () 0)))
  121.  
  122. (defun make-rectangle (w h)
  123.   (let* ((ctxt-ofst-l-pair (tile w h))
  124.      (new-field (make-field (allocate-paralation 
  125.                  (car ctxt-ofst-l-pair) (* w h))
  126.                 (cdr ctxt-ofst-l-pair))))
  127.     ((setter index-internal) (paralation new-field) new-field)
  128.     new-field))
  129.  
  130. ; Communication 
  131. ; =============
  132.  
  133. ; The key of our rectangular communication is a primitive function
  134. ; which performs a shift in a given direction for a row or column of a
  135. ; tiled virtual processor set. The lists of contexts and offsets
  136. ; specify a row or column in the correct order, the function does the
  137. ; shifts and handles all the edges of the tiles and wrap around. Thus
  138. ; the difficult part as far as the lisp is concerned is creating the
  139. ; right lists of contexts and offsets.
  140.  
  141. (defun partial-sub-list (l s n)
  142.   ;; generates a list from l of n elements taking every s'th element
  143.   ;; out of l.
  144.   (if (= n 0) ()
  145.     (cons (car l) (partial-sub-list (list-tail l s) s (- n 1)))))
  146.  
  147. (defun MP-XNET (ctxts ofsts d)
  148.   (format t "(mp-xnet ~a ~a ~a)\n" ctxts ofsts d)
  149.   (mp-xnet ctxts ofsts d))
  150.  
  151. (defun horizontal-lists (ctxts ofsts w d)
  152.   ;; generates lists of contexts and offsets which reperesent
  153.   ;; horizontal strips of the tiled virtual processor set. and then makes
  154.   ;; the appropriate mp-xnet call
  155.   (if (null ctxts) ()
  156.     (progn
  157.       (MP-XNET (partial-sub-list ctxts 1 w) (partial-sub-list ofsts 1 w) d)
  158.       (horizontal-lists (list-tail ctxts w) (list-tail ofsts w) w d))))
  159.  
  160. (defun vertical-lists (ctxts ofsts h w c d)
  161.   ;; generates lists of contexts and offsets which represent vertical
  162.   ;; strips of teh tiled virtual processor set. This is a little
  163.   ;; harder than the horizontal case. We stop when we have made width
  164.   ;; strips, thus c(ount) starts as w(idth). The tops of the columns
  165.   ;; are the first w elements of teh lists so we descend by one
  166.   ;; element each time. The partial lists are made up of elements
  167.   ;; w(idth) elements apart and they have h(eight) elements
  168.   (if (= c 0) ()
  169.     (progn
  170.       (MP-XNET (partial-sub-list ctxts w h) (partial-sub-list ofsts w h) d)
  171.       (vertical-lists (cdr ctxts) (cdr ofsts) h w (- c 1) d))))
  172.  
  173. ; Interfacing to get
  174. ; =========== == ===
  175.  
  176. ; a paralation has associated with it a vector of mappings, one for
  177. ; each direction. We place functions in these slots and put a test in
  178. ; get, if there is a function in a slot then it is applied to the
  179. ; field. We also need to know teh dimensions of the rectangle we can
  180. ; read this info from the attributes slot in the paralation structure.
  181.  
  182. (defclass rectangle-internal (paralation-internal)
  183.   ()
  184.   predicate rectangle-internal-p
  185.   constructor (allocate-rectangle contexts length attributes shape))
  186.  
  187. (defun rectanglep (f) (rectangle-internal-p (paralation f)))
  188.   
  189. (defconstant Width 0)
  190. (defconstant Height 1)
  191.  
  192. (defun make-rectangle-internal (w h)
  193.   ;; at this stage all we really need to know is its width and height
  194.   ;; in context tiles  
  195.   (let ((dimensions (make-vector 2)))
  196.     ((setter vector-ref) dimensions Width w)
  197.     ((setter vector-ref) dimensions Height h)
  198.     dimensions))
  199.  
  200. (defcondition bad-paralation-class ())
  201.  
  202. (defun rectangle-width (f)
  203.   (if (rectanglep f) (vector-ref (attributes (paralation f)) Width)
  204.     (error "Not a rectangle" bad-paralation-class)))
  205.  
  206. (defun rectangle-height (f)
  207.   (if (rectanglep f) (vector-ref (attributes (paralation f)) Height)
  208.     (error "Not a rectangle" bad-paralation-class)))
  209.  
  210. (defun width (f) (/ (+ (rectangle-width f) MP-X-Config (- 1)) MP-X-Config))
  211.  
  212. (defun height (f) (/ (+ (rectangle-height f) MP-Y-Config (- 1)) MP-Y-Config))
  213.  
  214. (defun get-north (f)
  215.   (when (not (rectanglep f)) (error "Not a rectangle" bad-paralation-class))
  216.   (vertical-lists (contexts f) (offsets f) (height f) (width f)
  217.           (width f) MP_NORTH)
  218.   f)
  219.  
  220. (defun get-south (f)
  221.   (when (not (rectanglep f)) (error "Not a rectangle" bad-paralation-class))
  222.   (vertical-lists (contexts f) (offsets f) (height f) (width f) 
  223.               (width f) MP_SOUTH)
  224.   f)
  225.  
  226. (defun get-east (f)
  227.   (when (not (rectanglep f)) (error "Not a rectangle" bad-paralation-class))
  228.   (horizontal-lists (contexts f) (offsets f) (width f) MP_EAST)
  229.   f)
  230.  
  231. (defun get-west (f)
  232.   (when (not (rectanglep f)) (error "Not a rectangle" bad-paralation-class))
  233.   (horizontal-lists (contexts f) (offsets f) (width f) MP_WEST)
  234.   f)
  235.  
  236. (setq rectangle-getters (make-vector 4))
  237.  
  238. (defconstant N MP_NORTH)
  239. (defconstant S MP_SOUTH)
  240. (defconstant E MP_EAST)
  241. (defconstant W MP_WEST)
  242.  
  243. ((setter vector-ref) rectangle-getters N get-north)
  244. ((setter vector-ref) rectangle-getters S get-south)
  245. ((setter vector-ref) rectangle-getters E get-east)
  246. ((setter vector-ref) rectangle-getters W get-west)
  247.  
  248. (defun make-rectangle (w h)
  249.   (let* ((ctxt-ofst-l-pair (tile w h))
  250.      (new-field (make-field (allocate-rectangle
  251.                  (car ctxt-ofst-l-pair) (* w h)
  252.                  (make-rectangle-internal w h)
  253.                  rectangle-getters)
  254.                 (cdr ctxt-ofst-l-pair))))
  255.     ((setter index-internal) (paralation new-field) new-field)
  256.     new-field))
  257.  
  258. (export make-rectangle rectanglep rectangle-width rectangle-height N S E W)
  259.      
  260.                  
  261. )
  262.  
  263.